home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
pcl
/
cl-nd-cl.lha
/
clue
/
clio
/
examples
/
sketch.lisp
< prev
next >
Wrap
Lisp/Scheme
|
1990-07-19
|
14KB
|
350 lines
;;; -*- Mode:Common-Lisp; Package:CLIO-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
;;;----------------------------------------------------------------------------------+
;;; |
;;; TEXAS INSTRUMENTS INCORPORATED |
;;; P.O. BOX 149149 |
;;; AUSTIN, TEXAS 78714-9149 |
;;; |
;;; Copyright (C) 1990 Texas Instruments Incorporated. |
;;; All Rights Reserved |
;;; |
;;; Use, duplication, or disclosure by the Government is subject to restrictions as |
;;; set forth in subdivision (b)(3)(ii) of the Rights in Technical Data and Computer |
;;; Software clause at 52.227-7013. |
;;; |
;;;----------------------------------------------------------------------------------+
(in-package "CLIO-EXAMPLES")
(defconstant
*sketch-help*
"SKETCH PAD is a simple drawing editor. You can draw graphical
primitives by clicking the pointer button to enter vertex points.
Complete a primitive by double-clicking on the final vertex.
Use the Graphics menu to select the type of primitive drawn.
Use the Attributes dialog to set attributes such as line width and fill
pattern.
Select Save from the File menu to save the drawing in a file. Select Open
from the File menu to read another drawing for editing.
To quit, select Quit from the File menu.")
(defun sketch (&key (host *default-host*) foreground background width height)
"A simple picture editor."
(let*
(;; Open connection to the host server.
(display (OPEN-CONTACT-DISPLAY 'sketch-pad :host host))
;; Determine pixels for foreground and background.
(screen (CONTACT-SCREEN (DISPLAY-ROOT display)))
(foreground (or foreground (screen-black-pixel screen)))
(background (or background (screen-white-pixel screen)))
;; Determine initial size of top-level-window.
(initial-width (or width 400))
(initial-height (or height 400))
;; Create top-level window
(top (MAKE-COMMAND-FRAME
:parent display
;; Initialize standard top-level properties.
:wm-title "Sketch Pad"
:wm-user-specified-size-p (and width height)
;; Specify initial geometry.
:x 0
:y 0
:width initial-width
:height initial-height
;; Set colors.
:background background
:foreground foreground
;; Content is a scroll-frame containing a sketchpad.
:content `(MAKE-SCROLL-FRAME
:content (make-sketchpad
:width ,initial-width
:height ,initial-height)))))
(declare (special display top))
;; Initialize control buttons.
(let*
((controls (COMMAND-FRAME-CONTROLS top))
(sketch (SCROLL-FRAME-CONTENT (COMMAND-FRAME-CONTENT top))))
;; Build File menu
(let*
((file-menu (MAKE-MENU
:parent controls
:name :file
:title "File"))
(choice (MENU-CHOICE file-menu)))
;; Add control to display File menu.
(MAKE-DIALOG-BUTTON
:parent controls
:name :file
:dialog file-menu
:label "File")
;; Add File menu items.
(let ((help-item (MAKE-ACTION-ITEM
:parent choice
:name :help
:label "Help")))
(ADD-CALLBACK
help-item :release ; Present help message when released.
'CONFIRM-P
:near sketch
:message *sketch-help*
:accept-only :on))
;; Build Open, Save dialogs...
(let*
((open-dialog (MAKE-PROPERTY-SHEET
:parent controls
:name :open
:wm-title "Sketch Pad Open"))
(open-area (PROPERTY-SHEET-AREA open-dialog))
(save-dialog (MAKE-PROPERTY-SHEET
:parent controls
:name :save
:wm-title "Sketch Pad Save"))
(save-area (PROPERTY-SHEET-AREA save-dialog)))
;; Add menu item to display Open dialog.
(MAKE-DIALOG-ITEM
:parent choice
:name :open
:label "Open"
:dialog open-dialog)
;; Add menu item to display Save dialog.
(MAKE-DIALOG-ITEM
:parent choice
:name :save
:label "Save"
:dialog save-dialog)
;; Add members to Open dialog...
(MAKE-DISPLAY-TEXT-FIELD
:parent open-area :source "Open File:" :display-gravity :east)
(let*
((initial-path (nstring-downcase
(namestring (make-pathname
:defaults (user-homedir-pathname)
:type "SKETCH"
:name "?"))))
(open-field (MAKE-EDIT-TEXT-FIELD
:parent open-area
:source initial-path
:length (+ (length initial-path) 12)))
initial-value)
;; Define callback functions for edit-text-field member.
(flet
((open-file
()
(with-open-file
(in (DISPLAY-TEXT-SOURCE open-field) :direction :input)
(setf (sketchpad-picture sketch) (read in))
(clear-area sketch :exposures-p t)))
(open-initial-value
()
(let*
((source (DISPLAY-TEXT-SOURCE open-field))
(name (pathname-name source))
(point (search name source :test #'char-equal)))
(setf initial-value source)
(setf (edit-text-point open-field) point)
(setf (edit-text-mark open-field) (+ (length name) point))))
(restore-initial-value
()
(setf (DISPLAY-TEXT-SOURCE open-field) initial-value)))
(ADD-CALLBACK open-field :initialize #'open-initial-value)
(ADD-CALLBACK open-field :accept #'open-file)
(ADD-CALLBACK open-field :complete #'dialog-accept open-dialog)
(ADD-CALLBACK open-field :cancel #'restore-initial-value))
;; Add members to Save dialog...
(MAKE-DISPLAY-TEXT-FIELD
:parent save-area :source "Save File:" :display-gravity :east)
(let
((save-field (MAKE-EDIT-TEXT-FIELD
:parent save-area)))
;; Define callback functions for edit-text-field member.
(flet
((save-file
()
(with-open-file
(out (DISPLAY-TEXT-SOURCE save-field) :direction :output)
(write (sketchpad-picture sketch) :stream out)))
(initialize-file
()
(let*
((source (DISPLAY-TEXT-SOURCE open-field))
(name (pathname-name source))
(point (search name source :test #'char-equal)))
(setf (DISPLAY-TEXT-SOURCE save-field) source)
(setf (EDIT-TEXT-FIELD-LENGTH save-field) (+ (length source) 12))
(setf (EDIT-TEXT-POINT save-field) point)
(setf (EDIT-TEXT-MARK save-field) (+ (length name) point)))))
(ADD-CALLBACK save-field :initialize #'initialize-file)
(ADD-CALLBACK save-field :accept #'save-file)
(ADD-CALLBACK save-field :complete #'dialog-accept save-dialog)))))
(MAKE-ACTION-ITEM
:parent choice
:name :quit
:label "Quit"
:callbacks (list
(list :release ; Exit event loop when released.
(list #'(lambda () (throw :quit nil)))))))
;; Build Graphics menu
(let*
((graphics-menu (MAKE-MENU
:parent controls
:name :graphics
:title "Graphics"))
(choice (MENU-CHOICE graphics-menu)))
;; Add control to display Graphics menu.
(MAKE-DIALOG-BUTTON
:parent controls
:name :graphics
:dialog graphics-menu
:label "Graphics")
(flet
((setf-sketchpad-mode (mode sp) (setf (sketchpad-mode sp) mode)))
;; Add Graphics menu items
(MAKE-ACTION-ITEM
:parent choice
:name :line
:label "Line"
:callbacks `((:release ; Change to :line mode when released.
(,#'setf-sketchpad-mode
:line
,sketch))))
(MAKE-ACTION-ITEM
:parent choice
:name :polygon
:label "Polygon"
:callbacks `((:release ; Change to :polygon mode when released.
(,#'setf-sketchpad-mode
:polygon
,sketch))))))
;; Build Attributes dialog
(let*
((attributes-dialog (MAKE-PROPERTY-SHEET
:parent controls
:name :attributes
:wm-title "Sketch Pad Attributes"))
(area (PROPERTY-SHEET-AREA attributes-dialog)))
;; Add control to display Attributes dialog.
(MAKE-DIALOG-BUTTON
:parent controls
:name :attributes
:label "Attributes"
:dialog attributes-dialog)
;; Add members to Attributes dialog...
;; ... a slider to change line width...
(MAKE-DISPLAY-TEXT-FIELD
:parent area :source "Line Width:" :display-gravity :east)
(let
((slider (MAKE-SLIDER
:parent area
:name :line-width
:minimum 1
:maximum 8
:increment 1
:orientation :horizontal))
initial-value)
;; Define callback functions for slider member.
(flet
((set-line-width
() (setf (sketchpad-line-width sketch) (SCALE-VALUE slider)))
(save-initial-value
() (setf initial-value (SCALE-VALUE slider)))
(restore-initial-value
() (setf (SCALE-VALUE slider) initial-value)))
(ADD-CALLBACK slider :initialize #'save-initial-value)
(ADD-CALLBACK slider :accept #'set-line-width)
(ADD-CALLBACK slider :cancel #'restore-initial-value)))
;; ... and "radio-buttons"-style choices to change fill pattern.
(MAKE-DISPLAY-TEXT-FIELD
:parent area :source "Fill Pattern:" :display-gravity :east)
(let
((choice (MAKE-CHOICES :parent area :name :fill :choice-policy :always-one))
initial-selection)
;; Define callback functions for choices member.
(flet
((set-fill-pattern
() (setf (sketchpad-fill sketch)
(APPLY-CALLBACK (CHOICE-SELECTION choice) :pattern)))
(save-initial-selection
() (setf initial-selection (CHOICE-SELECTION choice)))
(restore-initial-selection
() (setf (CHOICE-SELECTION choice) initial-selection)))
(ADD-CALLBACK choice :initialize #'save-initial-selection)
(ADD-CALLBACK choice :accept #'set-fill-pattern)
(ADD-CALLBACK choice :cancel #'restore-initial-selection)
;; Add choice items for each fill pattern. Define initial selection.
(MAKE-TOGGLE-BUTTON
:parent choice :label "White"
:callbacks `((:pattern (identity 0%gray))))
(MAKE-TOGGLE-BUTTON
:parent choice :label "Gray"
:callbacks `((:pattern (identity 50%gray))))
(setf (CHOICE-SELECTION choice)
(MAKE-TOGGLE-BUTTON
:parent choice :label "Black"
:callbacks `((:pattern (identity 100%gray)))))))))
(unwind-protect
;; Main event loop.
(catch :quit
(loop
(PROCESS-NEXT-EVENT display)))
;; Destroy window and close connection to server.
(close-display display))))